      subroutine parset_obj 
!-----------------------------------------------
!   M o d u l e s 
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double 
      use corgan_com_M 
      use cindex_com_M 
      use numpar_com_M 
      use cprplt_com_M, ONLY:  
      use cophys_com_M 
      use ctemp_com_M, ONLY: fmf, fef, fvf, fbxf, fbyf, fbzf, twx 
      use blcom_com_M, ONLY: x, y, z, vol, ijkcell, pmu, xptilde, yptilde, &
         zptilde, npsampl 
      use objects_com_M, ONLY: px_obj, py_obj, pz_obj, pxi_obj, peta_obj, &
         pzta_obj, chip_obj, link_obj, ico_obj, iphead_obj, massp_obj, &
         npcelx_obj, npcely_obj, npcelz_obj, rho_obj, chii_obj, icoi_obj, &
         theta1_obj, theta2_obj, phi1_obj, phi2_obj, nrg_obj, r_minor1_obj, &
         r_minor2_obj 
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:13:36   8/20/02  
!...Switches: -yf -x1             
!
      implicit none
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer , dimension(8) :: iv 
      integer , dimension(4) :: lioinput, lioprint 
      integer , dimension(8) :: ijkv 
      integer , dimension(27) :: ijkc 
      integer :: n, np, kr, kx, ky, kz 
      real(double), dimension(1) :: ixi1, ixi2, ieta1, ieta2 
      real(double) :: ixi4, ieta4, ixi5, ieta5 
      real(double), dimension(8) :: wght 
      real(double), dimension(100) :: fpxf, fpyf, fpzf, fpxft, fpyft, fpzft, &
         ucm, vcm, wcm, cm 
      real(double), dimension(3,20) :: wsin, wcos 
      real(double), dimension(3,12,20) :: tsi, rot 
      real(double), dimension(8) :: regvol 
      real(double), dimension(27) :: wghtc 
      real(double) :: nuxp, nuyp, nuzp, riwid, rjwid, rkwid, wsnc, rnpcx, rnpcy&
         , rnpcz, xi, eta, zta, phi, theta, r_minor, pvolume 
      logical :: expnd, nomore 
      character :: name*80 
!-----------------------------------------------
!
!
!
 
      riwid = 1./float(iwid) 
      rjwid = 1./float(jwid) 
      rkwid = 1./float(kwid) 
!
!     set up linked list
!
      iphead_obj(ijkcell(:ncells)) = 0 
!
      iphead_obj(1) = 1 
      do np = 1, npart_obj 
         pxi_obj(np) = 1. 
         peta_obj(np) = 1. 
         pzta_obj(np) = 1. 
!
         link_obj(np) = np + 1 
      end do 
      link_obj(npart_obj) = 0 
!
!
!     set all particle variables for np=0
!
      link_obj(0) = 0 
      px_obj(0) = 0.0 
      py_obj(0) = 0.0 
      pz_obj(0) = 0.0 
      pmu(0) = 0.0 
      pxi_obj(0) = 0.0 
      peta_obj(0) = 0.0 
      pzta_obj(0) = 0.0 
      chip_obj(0) = 0.0 
      ico_obj(0) = 0 
!
!     uniform distribution of particles throughout the volume
!     with random velocities
!
      npsampl = 0 
!
      do kr = 1, nrg_obj 
!
!
!
         wsnc = 1./(npcelx_obj(kr)*npcely_obj(kr)*npcelz_obj(kr)) 
         rnpcx = 1./float(npcelx_obj(kr)) 
         rnpcy = 1./float(npcely_obj(kr)) 
         rnpcz = 1./float(npcelz_obj(kr)) 
!
!
         do kx = 1, npcelx_obj(kr) 
            do ky = 1, npcely_obj(kr) 
               do kz = 1, npcelz_obj(kr) 
!
                  xi = (0.5 + (kx - 1))*rnpcx 
                  eta = (0.5 + (ky - 1))*rnpcy 
                  zta = (0.5 + (kz - 1))*rnpcz 
!
                  call weights (xi, eta, zta, wght) 
!
                  do n = 1, ncells 
!
                     ijk = ijkcell(n) 
                     ipjk = ijk + iwid 
                     ipjpk = ijk + iwid + jwid 
                     ijpk = ijk + jwid 
!
                     ijkp = ijk + kwid 
                     ipjkp = ijk + iwid + kwid 
                     ijpkp = ijk + jwid + kwid 
                     ipjpkp = ijk + iwid + jwid + kwid 
!
                     xptilde(ijk) = wght(1)*x(ipjk) + (wght(2)*x(ipjpk)+(wght(3&
                        )*x(ijpk)+(wght(4)*x(ijk)+(wght(5)*x(ipjkp)+(wght(6)*x(&
                        ipjpkp)+(wght(7)*x(ijpkp)+wght(8)*x(ijkp))))))) 
!
                     yptilde(ijk) = wght(1)*y(ipjk) + (wght(2)*y(ipjpk)+(wght(3&
                        )*y(ijpk)+(wght(4)*y(ijk)+(wght(5)*y(ipjkp)+(wght(6)*y(&
                        ipjpkp)+(wght(7)*y(ijpkp)+wght(8)*y(ijkp))))))) 
!
                     zptilde(ijk) = wght(1)*z(ipjk) + (wght(2)*z(ipjpk)+(wght(3&
                        )*z(ijpk)+(wght(4)*z(ijk)+(wght(5)*z(ipjkp)+(wght(6)*z(&
                        ipjpkp)+(wght(7)*z(ijpkp)+wght(8)*z(ijkp))))))) 
!
                  end do 
!
!     check whether particle is in region or not
!
                  do n = 1, ncells 
!
                     np = iphead_obj(1) 
                     if (np == 0) cycle  
                     ijk = ijkcell(n) 
                     call toroidal_coords (pi, rmaj, xptilde(ijk), yptilde(ijk)&
                        , zptilde(ijk), phi, theta, r_minor) 
!
!    check the results by back substitution
!
!      wsr=rmaj+r_minor*sin(theta)
!      z_chek=r_minor*cos(theta)
!      x_chek=wsr*cos(phi)
!      y_chek=wsr*sin(phi)
!c
!      write(*,*) 'theta,phi,r_minor=',theta,phi,r_minor
!      write(*,*) 'wspx,x_chek=',wspx,x_chek
!      write(*,*) 'wspy,y_chek=',wspy,y_chek
!      write(*,*) 'wspz,z_chek=',wspz,z_chek
                     if (.not.(theta>theta1_obj(kr) .and. theta<=theta2_obj(kr)&
                         .and. phi>phi1_obj(kr) .and. phi<=phi2_obj(kr) .and. &
                        r_minor>r_minor1_obj(kr) .and. r_minor<=r_minor2_obj(kr&
                        ))) cycle  
!
!
                     iphead_obj(1) = link_obj(np) 
                     link_obj(np) = iphead_obj(ijk) 
                     iphead_obj(ijk) = np 
!
                     k = 1 + int((ijk - 1)*rkwid) 
                     j = 1 + int((ijk - 1 - (k - 1)*kwid)*rjwid) 
                     i = 1 + int((ijk - 1 - (j - 1)*jwid - (k - 1)*kwid)*riwid) 
!
!
                     pxi_obj(np) = i + xi 
                     peta_obj(np) = j + eta 
                     pzta_obj(np) = k + zta 
!
                     px_obj(np) = xptilde(ijk) 
                     py_obj(np) = yptilde(ijk) 
                     pz_obj(np) = zptilde(ijk) 
!
                  end do 
!
!     calculate correct velocity distribution for 3 velocity components
!
!
!dir$ ivdep
                  do n = 1, ncells 
!
                     np = iphead_obj(ijkcell(n)) 
!
                     pvolume = vol(ijkcell(n))*wsnc 
!
                     ico_obj(np) = icoi_obj(kr) 
                     massp_obj(np) = pvolume*rho_obj(kr) 
!
                     chip_obj(np) = chii_obj(kr)*pvolume 
!
!
!
                  end do 
               end do 
            end do 
         end do 
      end do 
!
      return  
!
      end subroutine parset_obj 
